home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / tcl / spectcl-.000 / spectcl- / usr / local / SpecTcl-0.1a / toolbar.tk < prev    next >
Encoding:
Text File  |  1995-11-06  |  10.5 KB  |  431 lines
  1. # SpecTcl, by S. A. Uhler
  2. # Copyright (c) 1994-1995 Sun Microsystems, Inc.
  3. #
  4. # See the file "license.txt" for information on usage and redistribution
  5. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  6. #
  7. # toolbar management routines
  8.  
  9. # create the toolbar.  Its hardwired for now, but should be user programmable
  10. # Each toolbar has 3 procedures:
  11. #  setup_<tool>  - to setup the toolbar (optional)
  12. #  sync_<tool> win [options...] - to make tool value current with "win"
  13. #  set_<tool>  win                - to make the tool take affect
  14.  
  15. proc create_toolbar {win} {
  16.     global P
  17.     set column 0        ;# which column
  18.     
  19.     # The current item's text or label field
  20.  
  21.     label .text_label -text text
  22.     blt_table $win .text_label 0,[incr column]
  23.     entry .entry -textvariable Current(text) -relief ridge -width 15 -state disabled
  24.     blt_table $win .entry 0,[incr column]
  25.     
  26.     # set up bindings for immediate action on text entry
  27.  
  28.     bind fast <Delete> {change_entry %W}
  29.     bind fast <BackSpace> {change_entry %W}
  30.     bind fast <Return> "
  31.         %W insert insert {\n}
  32.         change_entry %W
  33.     "
  34.     bind fast <Key> {
  35.         if {[string length %A] > 0} {change_entry %W}
  36.     }
  37.  
  38.     bindtags .entry "[bindtags .entry] fast"
  39.     bind .entry <Return> {change_entry %W}
  40.  
  41.     foreach i {Left Right} {
  42.         bind .entry <$i> "short_cut $i;break"
  43.     }
  44.  
  45.     # the packing anchor
  46.  
  47.     setup_anchor .anchor Anchor set_anchor
  48.     blt_table $win .anchor 0,[incr column]
  49.     
  50.     # the packing fill
  51.  
  52.     setup_fill .fill Fill set_fill
  53.     blt_table $win .fill 0,[incr column]
  54.     
  55.     # the text justification
  56.  
  57.     setup_justify .justify just set_just
  58.     blt_table $win .justify 0,[incr column]
  59.     
  60.     # the relief setting 
  61.  
  62.     frame .relief -bd 2 -relief ridge
  63.     frame .relief.inside -bd 3 -bg grey  -width 12 -height 12
  64.     blt_table $win .relief 0,[incr column] -padx 1 -pady 1
  65.     blt_table .relief .relief.inside 0,0 -padx 1 -pady 1 -fill both
  66.     bind .relief.inside <1> {setup_reliefs %W.1 "set_relief %W"}
  67.     
  68.     # the font style
  69.  
  70.     label .style -bd 2 -relief ridge -text A
  71.     blt_table $win .style 0,[incr column] -padx 2 -pady 2
  72.     bind .style <1> "next_text_style %W"
  73.     # bind .style <1> "setup_style Fontstyle %W"
  74.     
  75.     # the foreground and background color
  76.  
  77.     label .fgcolor -bd 2 -relief ridge -text fg
  78.     blt_table $win .fgcolor 0,[incr column] -padx 2 -pady 2
  79.     bind .fgcolor <1> "setup_colors %W.1 Colors {set_color %W foreground}"
  80.     
  81.     label .bgcolor -bd 2 -relief ridge -text bg
  82.     blt_table $win .bgcolor 0,[incr column] -padx 2 -pady 2
  83.     bind .bgcolor <1> "setup_colors %W.1 Colors {set_color %W background}"
  84.     
  85.     # font size menu - too slow for testing
  86.     setup_fontsize .font_size Fontsize set_fontsize
  87.     blt_table $win .font_size 0,[incr column]
  88.     
  89.     setup_borderwidth .borderwidth Borderwidth set_borderwidth
  90.     blt_table $win .borderwidth 0,[incr column]
  91.     
  92.     setup_orient .orient Orient set_orient
  93.     blt_table $win .orient 0,[incr column]
  94. }
  95.  
  96. # this is the list of toolbars
  97.  
  98. set Toolbar {
  99.     entry anchor fill justify relief style fgcolor
  100.     bgcolor font_size borderwidth orient
  101. }
  102.  
  103. ####################################################################
  104. # update the setting of the toolbars to reflect the current widget
  105.  
  106. # update the data in the current widget and its array
  107. # This one is invoked during keystrokes via the bindings
  108.  
  109. proc change_entry {win} {
  110.     global P Current
  111.     if {[set widget $Current(widget)] == ""} {
  112.         return 0
  113.     }
  114.  
  115.     foreach item {text label} {
  116.         if {[catch {$widget cget -$item}]} continue
  117.         $widget configure -$item $Current(text)
  118.         sync_form $item $Current(text)
  119.     }
  120.     return 1
  121. }
  122.  
  123. # reflect text of current widget into entry field
  124.  
  125. proc sync_entry {win} {
  126.     global Current P
  127.     if {[set widget $Current(widget)] == ""} {
  128.         return 0
  129.     }
  130.     if {[catch {set text [$widget cget -text]}] && \
  131.             [catch {set text [$widget cget -label]}]} {
  132.         $win configure -state disabled
  133.         set Current(text) ""
  134.         return 0
  135.     } else {
  136.         set Current(text) $text
  137.         $win configure -state normal
  138.         $win selection range 0 end
  139.         return 1
  140.     }
  141. }
  142.  
  143. proc sync_anchor {win} {
  144.     global Current
  145.     if {[set widget $Current(widget)] == ""} {
  146.         return 0
  147.     }
  148.     array set options [blt_table info $widget]
  149.     if {$options(-anchor) == "center"} {set options(-anchor) "c"}
  150.     $win configure -image $options(-anchor)_anchor
  151. }
  152.  
  153. proc sync_fill {win} {
  154.     global Current
  155.     if {[set widget $Current(widget)] == ""} {
  156.         return 0
  157.     }
  158.     array set options [blt_table info $widget]
  159.     $win configure -image $options(-fill)_fill
  160. }
  161.  
  162. proc sync_borderwidth {win} {
  163.     global Current Borderwidth
  164.     if {[set widget $Current(widget)] == ""} {
  165.         return 0
  166.     }
  167.     if {[catch {set Borderwidth [$widget cget -bd]}]} {
  168.         $win configure -state disabled
  169.     } else {
  170.         $win configure -state normal
  171.     }
  172. }
  173.  
  174. proc sync_justify {win} {
  175.     global Current
  176.     if {[set widget $Current(widget)] == ""} {
  177.         return 0
  178.     }
  179.     if {[catch {set justify [$widget cget -justify]}]} {
  180.         $win configure -state disabled
  181.     } else {
  182.         $win configure -image ${justify}_just -state normal
  183.     }
  184. }
  185.  
  186. proc sync_relief {win} {
  187.     global Current
  188.     if {[set widget $Current(widget)] == ""} {
  189.         return 0
  190.     }
  191.     set relief [$widget cget -relief]
  192.     $win.inside configure -relief $relief
  193. }
  194.  
  195. proc sync_fgcolor {win} {
  196.     global Current
  197.     if {[set widget $Current(widget)] == ""} {
  198.         return 0
  199.     }
  200.     if {[catch {set color [$widget cget -fg]}]} {
  201.     } else {
  202.         $win configure -fg [contrast_color $color] -bg $color
  203.     }
  204. }
  205.  
  206. proc sync_bgcolor {win} {
  207.     global Current
  208.     if {[set widget $Current(widget)] == ""} {
  209.         return 0
  210.     }
  211.     if {[catch {set color [$widget cget -bg]}]} {
  212.     } else {
  213.         $win configure -fg [contrast_color $color]  -bg $color
  214.     }
  215. }
  216.  
  217. proc sync_style {win} {
  218.     global Current
  219.     if {[set widget $Current(widget)] == ""} {
  220.         return 0
  221.     }
  222.     if {[catch {set font [$widget cget -font]}]} {
  223.         $win configure -bg grey
  224.     } else {
  225.         InFilter_font font
  226.         set current [$win cget -font]
  227.         InFilter_font current
  228.         regexp {([^,]*,[^,]*),*(.*)} $font dummy base style
  229.         regexp {([^,]*,[^,]*),*(.*)} $current dummy c_base c_style
  230.         set font $c_base,$style
  231.         OutFilter_font dymmy font font
  232.         $win configure -font $font -bg [[winfo parent $win] cget -bg]
  233.     }
  234. }
  235.  
  236. proc sync_font_size {win} {
  237.     global Current Fontsize
  238.     if {[set widget $Current(widget)] == ""} {
  239.         return 0
  240.     }
  241.     if {[catch {set font [$widget cget -font]}]} {
  242.         $win configure -bg grey
  243.     } else {
  244.         $win configure -bg [[winfo parent $win] cget -bg]
  245.         InFilter_font font
  246.         regexp {([^,]*),([^,]*),*(.*)} $font dummy family size style
  247.         set Fontsize $size
  248.     }
  249. }
  250.  
  251. # now sync all of the toolbars
  252.  
  253. proc sync_all {win} {
  254.     global Toolbar
  255.     foreach i $Toolbar {
  256.         sync_$i $win.$i
  257.     }
  258. }    
  259.  
  260. ######################################################################
  261. # set the anchor value - need to update the form too
  262.  
  263. proc set_anchor {style} {
  264.     global Current
  265.     if {[set widget $Current(widget)] == ""} {
  266.         return 0
  267.     }
  268.     catch "blt_table configure $widget -anchor $style"
  269.     sync_form align $style
  270.     set Current(repeat) "set_anchor $style"
  271. }
  272.  
  273. # set the fill value - need to update the form too
  274.  
  275. proc set_fill {style} {
  276.     global Current
  277.     set bad [catch "blt_table configure $Current(widget) -fill $style"]
  278.     if {$bad} {
  279.         global _Message
  280.         set _Message "This item has no \"fill\" option"
  281.     } else {
  282.         sync_form fill $style
  283.     }
  284.     set Current(repeat) "set_fill $style"
  285. }
  286.  
  287. # set the justify value - need to update the form too
  288.  
  289. proc set_just {style} {
  290.     global Current
  291.     set bad [catch "$Current(widget) configure -justify $style"]
  292.     if {$bad} {
  293.         global _Message
  294.         set _Message "This item has no \"justify\" option"
  295.     } else {
  296.         sync_form fill $style
  297.     }
  298.     set Current(repeat) "set_just $style"
  299. }
  300.  
  301. # set the border size - need to update the form too
  302.  
  303. proc set_borderwidth {style} {
  304.     global Current Borderwidth
  305.     set bad [catch "$Current(widget) configure -bd $style"]
  306.     if {$bad} {
  307.         global _Message
  308.         set _Message "This item has no \"borderwidth\" option"
  309.     } else {
  310.         sync_form borderwidth $style
  311.     }
  312.     set Current(repeat) "set_borderwidth $style"
  313. }
  314.  
  315. # set the font size
  316.  
  317. proc set_fontsize {size} {
  318.     global Current _Message Fontsize
  319.     if {[set widget $Current(widget)] == ""} {
  320.         return 0
  321.     }
  322.     if {[catch {set font [$widget cget -font]}]} {
  323.         set _Message "This item has no \"font size\" option"
  324.         return
  325.     }
  326.     InFilter_font font
  327.     regexp {([^,]*),([^,]*),*(.*)} $font dummy family size style
  328.     set font $family,$Fontsize,$style
  329.     if {![OutFilter_font dummy font font]} { 
  330.         set _Message "font size $Fontsize is invalid for $family,$style"
  331.         return
  332.     }
  333.     $widget configure -font $font
  334.     sync_form font $font
  335.     set Current(repeat) "set_fontsize $size"
  336. }
  337.  
  338. # set the color value - need to update the form too
  339.  
  340. proc set_color {win what style} {
  341.     global Current
  342.     set bad [catch "$Current(widget) configure -$what $style"]
  343.     if {$bad} {
  344.         global _Message
  345.         set _Message "This item has no \"$what\" color option"
  346.     } else {
  347.         $win configure -bg $style -fg [contrast_color $style]
  348.         sync_form $what $style
  349.         # heuristic
  350.         if {$what == "foreground" && [catch { \
  351.                 $Current(widget) configure -activeforeground $style}] == 0} {
  352.             sync_form activeforeground $style
  353.         }
  354.     }
  355.     set Current(repeat) "set_color $win $what $style"
  356. }
  357.  
  358. # set the selected widget (and toolbar icon) to the proper relief
  359.  
  360. proc set_relief {win relief} {
  361.     global Current _Message
  362.  
  363.     $win configure -relief $relief
  364.     if {[set widget $Current(widget)] == ""} {
  365.         return 0
  366.     }
  367.     $widget configure -relief $relief
  368.     sync_form relief $relief
  369.     set Current(repeat) "set_relief $relief"
  370. }
  371.  
  372. #########################################
  373. # procedure to create border size menu
  374.  
  375. proc setup_borderwidth {win name {command puts}} {
  376.     global _Message
  377.     upvar #0 $name var
  378.     if {![info exists var]} {set var 2}
  379.     menubutton $win -menu $win.borderwidth -width 2 \
  380.         -textvariable $name -bd 2 -relief ridge -padx 1 -pady 1
  381.     menu $win.borderwidth
  382.     foreach item {0 1 2 4 8 12} {
  383.         $win.borderwidth add command -label $item  -command "
  384.                 set $name $item
  385.                 eval \"$command $item\"
  386.             "
  387.     }
  388. }
  389.  
  390. # select orientation (scrollbars and scales only) - placeholder
  391.  
  392. proc setup_orient {win name {command puts}} {
  393.     global _Message
  394.     upvar #0 $name var
  395.     if {![info exists var]} {set var v}
  396.     menubutton $win -menu $win.orient \
  397.         -textvariable $name -bd 2 -relief ridge -padx 1 -pady 1
  398.     menu $win.orient
  399.     foreach item {vertical horizontal} {
  400.         $win.orient add command -label $item  -command "
  401.                 set $name [string range $item 0 0]
  402.                 eval \"$command $item\"
  403.             "
  404.     }
  405. }
  406.  
  407. proc sync_orient {win} {
  408.     global Current Orient
  409.     if {[set widget $Current(widget)] == ""} {
  410.         return 0
  411.     }
  412.     if {[catch {set orient [$widget cget -orient]}]} {
  413.         $win configure -state disabled
  414.     } else {
  415.         set Orient [string range $orient 0 0]
  416.         $win configure -state normal
  417.     }
  418. }
  419.  
  420. proc set_orient {style} {
  421.     global Current Orient
  422.     set bad [catch "$Current(widget) configure -orient $style"]
  423.     if {$bad} {
  424.         global _Message
  425.         set _Message "This item has no \"orient\" option"
  426.     } else {
  427.         sync_form orient $style
  428.         orient_create $Current(widget)
  429.     }
  430. }
  431.